home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / xlisp2.arc / XLREAD.C < prev    next >
Text File  |  1985-01-01  |  9KB  |  406 lines
  1. /* xlread - xlisp expression input routine */
  2.  
  3. #include "xlisp.h"
  4.  
  5. /* external variables */
  6. extern NODE *s_stdout,*true;
  7. extern NODE *s_quote,*s_function,*s_bquote,*s_comma,*s_comat;
  8. extern NODE *xlstack;
  9. extern int xlplevel;
  10.  
  11. /* external routines */
  12. extern FILE *fopen();
  13.  
  14. /* forward declarations */
  15. FORWARD NODE *plist();
  16. FORWARD NODE *pstring();
  17. FORWARD NODE *pquote();
  18. FORWARD NODE *pname();
  19.  
  20. /* xlload - load a file of xlisp expressions */
  21. int xlload(name,vflag,pflag)
  22.   char *name; int vflag,pflag;
  23. {
  24.     NODE *oldstk,fptr,expr;
  25.     char fname[50];
  26.     CONTEXT cntxt;
  27.     int sts;
  28.  
  29.     /* create a new stack frame */
  30.     oldstk = xlsave(&fptr,&expr,NULL);
  31.  
  32.     /* allocate a file node */
  33.     fptr.n_ptr = newnode(FPTR);
  34.     fptr.n_ptr->n_fp = NULL;
  35.     fptr.n_ptr->n_savech = 0;
  36.  
  37.     /* create the file name and print the information line */
  38.     strcpy(fname,name); strcat(fname,".lsp");
  39.     if (vflag)
  40.     printf("; loading \"%s\"\n",fname);
  41.  
  42.     /* open the file */
  43.     if ((fptr.n_ptr->n_fp = fopen(fname,"r")) == NULL) {
  44.     xlstack = oldstk;
  45.     return (FALSE);
  46.     }
  47.  
  48.     /* read, evaluate and possibly print each expression in the file */
  49.     xlbegin(&cntxt,CF_ERROR,true);
  50.     if (setjmp(cntxt.c_jmpbuf))
  51.     sts = FALSE;
  52.     else {
  53.     while (xlread(fptr.n_ptr,&expr.n_ptr)) {
  54.         expr.n_ptr = xleval(expr.n_ptr);
  55.         if (pflag)
  56.         stdprint(expr.n_ptr);
  57.     }
  58.     sts = TRUE;
  59.     }
  60.     xlend(&cntxt);
  61.  
  62.     /* close the file */
  63.     fclose(fptr.n_ptr->n_fp);
  64.     fptr.n_ptr->n_fp = NULL;
  65.  
  66.     /* restore the previous stack frame */
  67.     xlstack = oldstk;
  68.  
  69.     /* return status */
  70.     return (sts);
  71. }
  72.  
  73. /* xlread - read an xlisp expression */
  74. int xlread(fptr,pval)
  75.   NODE *fptr,**pval;
  76. {
  77.     /* initialize */
  78.     xlplevel = 0;
  79.  
  80.     /* parse an expression */
  81.     return (parse(fptr,pval));
  82. }
  83.  
  84. /* parse - parse an xlisp expression */
  85. LOCAL int parse(fptr,pval)
  86.   NODE *fptr,**pval;
  87. {
  88.     int ch;
  89.  
  90.     /* keep looking for a node skipping comments */
  91.     while (TRUE)
  92.  
  93.     /* check next character for type of node */
  94.     switch (ch = nextch(fptr)) {
  95.     case EOF:
  96.         xlgetc(fptr);
  97.         return (FALSE);
  98.     case '\'':            /* a quoted expression */
  99.         xlgetc(fptr);
  100.         *pval = pquote(fptr,s_quote);
  101.         return (TRUE);
  102.     case '#':            /* a quoted function */
  103.         xlgetc(fptr);
  104.         if ((ch = xlgetc(fptr)) == '<')
  105.             xlfail("unreadable atom");
  106.         else if (ch != '\'')
  107.             xlfail("expected quote after #");
  108.         *pval = pquote(fptr,s_function);
  109.         return (TRUE);
  110.     case '`':            /* a back quoted expression */
  111.         xlgetc(fptr);
  112.         *pval = pquote(fptr,s_bquote);
  113.         return (TRUE);
  114.     case ',':            /* a comma or comma-at expression */
  115.         xlgetc(fptr);
  116.         if (xlpeek(fptr) == '@') {
  117.             xlgetc(fptr);
  118.             *pval = pquote(fptr,s_comat);
  119.         }
  120.         else
  121.             *pval = pquote(fptr,s_comma);
  122.         return (TRUE);
  123.     case '(':            /* a sublist */
  124.         *pval = plist(fptr);
  125.         return (TRUE);
  126.     case ')':            /* closing paren - shouldn't happen */
  127.         xlfail("extra right paren");
  128.     case '.':            /* dot - shouldn't happen */
  129.         xlfail("misplaced dot");
  130.     case ';':            /* a comment */
  131.         pcomment(fptr);
  132.         break;
  133.     case '"':            /* a string */
  134.         *pval = pstring(fptr);
  135.         return (TRUE);
  136.     default:
  137.         if (issym(ch))        /* a name */
  138.             *pval = pname(fptr);
  139.         else
  140.             xlfail("invalid character");
  141.         return (TRUE);
  142.     }
  143. }
  144.  
  145. /* pcomment - parse a comment */
  146. LOCAL pcomment(fptr)
  147.   NODE *fptr;
  148. {
  149.     int ch;
  150.  
  151.     /* skip to end of line */
  152.     while ((ch = checkeof(fptr)) != EOF && ch != '\n')
  153.     ;
  154. }
  155.  
  156. /* plist - parse a list */
  157. LOCAL NODE *plist(fptr)
  158.   NODE *fptr;
  159. {
  160.     NODE *oldstk,val,*lastnptr,*nptr,*p;
  161.     int ch;
  162.  
  163.     /* increment the nesting level */
  164.     xlplevel += 1;
  165.  
  166.     /* create a new stack frame */
  167.     oldstk = xlsave(&val,NULL);
  168.  
  169.     /* skip the opening paren */
  170.     xlgetc(fptr);
  171.  
  172.     /* keep appending nodes until a closing paren is found */
  173.     lastnptr = NULL;
  174.     for (lastnptr = NULL; (ch = nextch(fptr)) != ')'; lastnptr = nptr) {
  175.  
  176.     /* check for end of file */
  177.     if (ch == EOF)
  178.         badeof(fptr);
  179.  
  180.     /* check for a dotted pair */
  181.     if (ch == '.') {
  182.  
  183.         /* skip the dot */
  184.         xlgetc(fptr);
  185.  
  186.         /* make sure there's a node */
  187.         if (lastnptr == NULL)
  188.         xlfail("invalid dotted pair");
  189.  
  190.         /* parse the expression after the dot */
  191.         if (!parse(fptr,&p))
  192.         badeof(fptr);
  193.         rplacd(lastnptr,p);
  194.  
  195.         /* make sure its followed by a close paren */
  196.         if (nextch(fptr) != ')')
  197.         xlfail("invalid dotted pair");
  198.  
  199.         /* done with this list */
  200.         break;
  201.     }
  202.  
  203.     /* allocate a new node and link it into the list */
  204.     nptr = newnode(LIST);
  205.     if (lastnptr == NULL)
  206.         val.n_ptr = nptr;
  207.     else
  208.         rplacd(lastnptr,nptr);
  209.  
  210.     /* initialize the new node */
  211.     if (!parse(fptr,&p))
  212.         badeof(fptr);
  213.     rplaca(nptr,p);
  214.     }
  215.  
  216.     /* skip the closing paren */
  217.     xlgetc(fptr);
  218.  
  219.     /* restore the previous stack frame */
  220.     xlstack = oldstk;
  221.  
  222.     /* decrement the nesting level */
  223.     xlplevel -= 1;
  224.  
  225.     /* return successfully */
  226.     return (val.n_ptr);
  227. }
  228.  
  229. /* pstring - parse a string */
  230. LOCAL NODE *pstring(fptr)
  231.   NODE *fptr;
  232. {
  233.     NODE *oldstk,val;
  234.     char sbuf[STRMAX+1];
  235.     int ch,i,d1,d2,d3;
  236.  
  237.     /* create a new stack frame */
  238.     oldstk = xlsave(&val,NULL);
  239.  
  240.     /* skip the opening quote */
  241.     xlgetc(fptr);
  242.  
  243.     /* loop looking for a closing quote */
  244.     for (i = 0; i < STRMAX && (ch = checkeof(fptr)) != '"'; i++) {
  245.     switch (ch) {
  246.     case EOF:
  247.         badeof(fptr);
  248.     case '\\':
  249.         switch (ch = checkeof(fptr)) {
  250.         case 'e':
  251.             ch = '\033';
  252.             break;
  253.         case 'n':
  254.             ch = '\n';
  255.             break;
  256.         case 'r':
  257.             ch = '\r';
  258.             break;
  259.         case 't':
  260.             ch = '\t';
  261.             break;
  262.         default:
  263.             if (ch >= '0' && ch <= '7') {
  264.                 d1 = ch - '0';
  265.                 d2 = checkeof(fptr) - '0';
  266.                 d3 = checkeof(fptr) - '0';
  267.                 ch = (d1 << 6) + (d2 << 3) + d3;
  268.             }
  269.             break;
  270.         }
  271.     }
  272.     sbuf[i] = ch;
  273.     }
  274.     sbuf[i] = 0;
  275.  
  276.     /* initialize the node */
  277.     val.n_ptr = newnode(STR);
  278.     val.n_ptr->n_str = strsave(sbuf);
  279.     val.n_ptr->n_strtype = DYNAMIC;
  280.  
  281.     /* restore the previous stack frame */
  282.     xlstack = oldstk;
  283.  
  284.     /* return the new string */
  285.     return (val.n_ptr);
  286. }
  287.  
  288. /* pquote - parse a quoted expression */
  289. LOCAL NODE *pquote(fptr,sym)
  290.   NODE *fptr,*sym;
  291. {
  292.     NODE *oldstk,val,*p;
  293.  
  294.     /* create a new stack frame */
  295.     oldstk = xlsave(&val,NULL);
  296.  
  297.     /* allocate two nodes */
  298.     val.n_ptr = newnode(LIST);
  299.     rplaca(val.n_ptr,sym);
  300.     rplacd(val.n_ptr,newnode(LIST));
  301.  
  302.     /* initialize the second to point to the quoted expression */
  303.     if (!parse(fptr,&p))
  304.     badeof(fptr);
  305.     rplaca(cdr(val.n_ptr),p);
  306.  
  307.     /* restore the previous stack frame */
  308.     xlstack = oldstk;
  309.  
  310.     /* return the quoted expression */
  311.     return (val.n_ptr);
  312. }
  313.  
  314. /* pname - parse a symbol name */
  315. LOCAL NODE *pname(fptr)
  316.   NODE *fptr;
  317. {
  318.     char sname[STRMAX+1];
  319.     NODE *val;
  320.     int i;
  321.  
  322.     /* get symbol name */
  323.     for (i = 0; i < STRMAX && issym(xlpeek(fptr)); )
  324.     sname[i++] = xlgetc(fptr);
  325.     sname[i] = 0;
  326.  
  327.     /* check for a number or enter the symbol into the oblist */
  328.     return (isnumber(sname,&val) ? val : xlenter(sname,DYNAMIC));
  329. }
  330.  
  331. /* nextch - look at the next non-blank character */
  332. LOCAL int nextch(fptr)
  333.   NODE *fptr;
  334. {
  335.     int ch;
  336.  
  337.     /* return and save the next non-blank character */
  338.     while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
  339.     xlgetc(fptr);
  340.     return (ch);
  341. }
  342.  
  343. /* checkeof - get a character and check for end of file */
  344. LOCAL int checkeof(fptr)
  345.   NODE *fptr;
  346. {
  347.     int ch;
  348.  
  349.     if ((ch = xlgetc(fptr)) == EOF)
  350.     badeof(fptr);
  351.     return (ch);
  352. }
  353.  
  354. /* badeof - unexpected eof */
  355. LOCAL badeof(fptr)
  356.   NODE *fptr;
  357. {
  358.     xlgetc(fptr);
  359.     xlfail("unexpected EOF");
  360. }
  361.  
  362. /* isnumber - check if this string is a number */
  363. int isnumber(str,pval)
  364.   char *str; NODE **pval;
  365. {
  366.     char *p;
  367.     int d;
  368.  
  369.     /* initialize */
  370.     p = str; d = 0;
  371.  
  372.     /* check for a sign */
  373.     if (*p == '+' || *p == '-')
  374.     p++;
  375.  
  376.     /* check for a string of digits */
  377.     while (isdigit(*p))
  378.     p++, d++;
  379.  
  380.     /* make sure there was at least one digit and this is the end */
  381.     if (d == 0 || *p)
  382.     return (FALSE);
  383.  
  384.     /* convert the string to an integer and return successfully */
  385.     *pval = newnode(INT);
  386.     (*pval)->n_int = atoi(*str == '+' ? ++str : str);
  387.     return (TRUE);
  388. }
  389.  
  390. /* issym - check whether a character if valid in a symbol name */
  391. LOCAL int issym(ch)
  392.   int ch;
  393. {
  394.     if (ch <= ' ' || ch >= 0177 ||
  395.         ch == '(' ||
  396.         ch == ')' ||
  397.         ch == ';' || 
  398.     ch == ',' ||
  399.     ch == '`' ||
  400.         ch == '"' ||
  401.         ch == '\'')
  402.     return (FALSE);
  403.     else
  404.     return (TRUE);
  405. }
  406.